00100		TITLE PRIM
00200	;ACCUMULATOR DEFINITIONS
00300	P←14
00400	F←15
00500	FF←16
00600
00700	A←1
00800	B←2
00900	C←3
00902	D←4
01000	T←6
01100	R←13
01200	TT←7
01300	NIL←0
01400	INUM0←577777
01500
01600
01700	;LISP FUNCTION CALL UUO'S
01800	OPDEF CALL [34B8]
01900	OPDEF JCALL [35B8]
02000	OPDEF CALLF [36B8]
02100	OPDEF JCALLF [37B8]
02200
02300	EXTERNAL TRUTH,INTERN,CHRCT,FLATSIZE,ATOM,SCAN,SCNVAL
02400	EXTERNAL NILX,STAR,READP1
02500
02600
02700	NILRET:	MOVEI A,NIL
02800		POPJ P,
02900
03000	TRET:	MOVEI A,TRUTH
03100		POPJ P,
03200
03300
03400	LOSE:	PUSHJ P,UNWIND
03500	NILXR:	MOVEI A,NILX	;NILX IS *NIL*
03600		POPJ P,
     

00100	
00200	REDPTR:	0
00300
00400	INTERNAL XXTRY,ATM
00500	
00600	ATM:	PUSHJ P,LOOK
00700		MOVEI A,INUM0+3
00800		CAIN A,(B)	;IS IT A DELIMITER?
00900		JRST UNWIND	;YES, LOSE
01000		JRST TRY2	;NO, IT IS AN ATOM -- ACCEPT IT
01100	
01200	XXTRY:	PUSHJ P,LOOK
01300		CAIE A,(B)
01400		JRST UNWIND
01500	TRY2:	SOS BKUPTR
01600		AOS REDPTR
01700		MOVEM B,@REDPTR
01800		JRST TRET
01900	
02000	INTERNAL ISIT,ISITN
02100	EXTERNAL ACONS
02200	ISITN: SETOM ISFLG#
02300		JRST .+2
02400	ISIT:	SETZM ISFLG#
02500		JUMPE A,NILRET	;IT ISN'T
02600		PUSH P,A	;MAYBE
02700		PUSHJ P,LOOK
02800		HLRZ A,B
02900		HRRZ C,B
03000		CAIN C,INUM0+0
03100		JRST ISIT1
03200		CAIN C,INUM0+1
03300		JRST ISIT4	;LOSE ON STRINGS
03400		CAIN C,INUM0+2
03500		JRST ISIT1	;TAKE NUMBERS
03525		CAIE C,INUM0+3
03537		JRST ISIT4 ;LOSE AGAIN
03550		PUSH P,B
03600		PUSHJ P,ACONS-7	;H.S. TO ASCII
03700		PUSHJ P,INTERN
03750		POP P,B
03800	ISIT1:	POP P,D	;NOW MEMQ IT
03900		MOVS C,(D)
04000		CAIN A,(C)
04100		JRST ISIT2	;IT IS
04200		HLRZ D,C
04300		JUMPN D,ISIT1+1
04350		SKIPN ISFLG
04375		JRST UNWIND
04377	ISIT3:	SOS BKUPTR
04379		AOS REDPTR
04381		MOVEM B,@REDPTR
04383		POPJ P,0
04385	ISIT4:	POP P,A
04387		JRST UNWIND
04402	ISIT2:	SKIPE ISFLG
04404		JRST UNWIND
04406		JRST ISIT3
04408	
04500	LOOK:	SKIPE B,@BKUPTR
04600		POPJ P,
04700		PUSH P,A
04800		PUSHJ P,SCAN
04900		CAIN A,INUM0
05000		JRST	[MOVE A,SCNVAL
05100			PUSHJ P,INTERN
05200			MOVSS A
05300			HRRI A,INUM0
05400			JRST LOOK2]
05500		HRL A,SCNVAL
05600	LOOK2:	AOS BKUPTR
05700		MOVEM A,@BKUPTR
05800		MOVE B,A
05900		POP P,A
06000		POPJ P,
06100	
06200	INTERNAL SPWDX,CHX
06300	SPWDX:	HRLI A,INUM0
06400		JRST .+2
06500	CHX:	HRLI A,INUM0+3
06600		MOVSS A
06700		PUSHJ P,LOOK
06800		CAME A,B	;IS BOTH TYPE AND VALUE THE SAME?
06900		JRST UNWIND	;NO, LOSE
07000		JRST TRY2	;YES, TAKE IT
07100	
     

00100	INTERNAL STK,PDLSET
00200
00300	STK:	MOVNI A,-INUM0(A)	;THIS SHOULD BE NEGATIVE NUMVAL
00400		ADD A,REDPTR	;0 IS THE TOP OF THE STACK
00500		HLRZ A,(A)	;THE SEMANTIC VALUE IS IN THE LEFT HALF
00600		POPJ P,
00700
00800	;PDLSET INITIALIZES PDLPTR TO POINT TO A LISP ARRAY 
00900
01000	PDLSET:	ADDI B,12
01100		ADDI A,12	;GET ADDRESSES OF 1ST ARRAY WORDS
01200		MOVEM A,REDPTR
01300		MOVEM B,BKUPTR
01400		SETZM @BKUPTR
01500		JRST MARK
     

00100
00200	
00300	INTERNAL REDUCE
00400	;REDUCE RESETS TO STACK TO BELOW THE MARK
00500	;A CONTAINS SYNTACTIC VALUE, B CONTAINS SEMANTIC VALUE
00600	REDUCE:	PUSHJ P,UNMARK	;RESET STACK TO BELOW MARK
00700		CAIN B,NILX	;IS SEMANTIC VALUE *NIL*?
00800		JRST UNWIND	;YES, UNWIND STACK TO PREVIOUS MARK
00900		HRL A,B	;NO, CONSTRUCT REDUCTION WORD
01000		AOS REDPTR
01100		MOVEM A,@REDPTR		;PUSH IT ONTO REDUCTION STACK
01200		JRST TRET
01300
01400	UNMARK:	HRRO T,REDMRK#
01500		POP T,REDMRK	;RESTORE REDMRK TO ITS PREVIOUS VALUE
01600		HRRZM T,REDPTR	;RESTORE REDPTR TO BELOW REDMRK
01700		POPJ P,
01800	
01900	MARK:	HRRZ T,REDPTR
02000		PUSH T,REDMRK	;SAVE REDMRK
02100		HRROM T,REDMRK	;REMEMBER WHERE REDMRK SAVED
02200		HRRZM T,REDPTR	;UPDATE REDPTR
02300		JRST NILRET	;PDL OVERFLOW CHECKING HERE?
02400	
02500	UNWIND:	HRRO T,REDPTR
02600		SKIPA TT,BKUPTR#
02700	UNWIN2:	PUSH TT,A
02800		POP T,A		;GET A WORD FROM REDUCTION PDL
02900		TLC A,-1
03000		TLCE A,-1
03100		JRST UNWIN2	;IF NOT A MARK, TRANSFER IT TO BACKUP PDL
03200		PUSH T,A	;FOUND A MARK, RESTORE IT
03300		HRRZM T,REDPTR	;AND UPDATE POINTERS
03400		HRRZM TT,BKUPTR
03500		JRST NILRET	;PDL OVERFLOW CHECKING HERE?
03600	
     

00100
00200	
00300	ISSTR:	MOVE B,@BKUPTR	;GET TOP OF BACKUP STACK
00400		CAIE A,(B)	;IS IT THE PROPER TYPE?
00500		JRST MARK	;NO, PROCEED WITH RULE
00600		SOS BKUPTR	;YES, TRANSFER IT TO REDUCTION PDL
00700		AOS REDPTR
00800		MOVEM B,@REDPTR
00900		JRST TRET
     

00100	
00200	
00300	INTERNAL LRR,NLRR
00400
00500	;LRR--LEFT RECURSIVE RULE
00600	;A CONTAINS NAME OF RULE
00700	;B CONTAINS NON LEFT-RECURSIVE FUNCTION
00800	;C CONTAINS LEFT-RECURSIVE FUNCTION
00900
01000	LRR:	PUSH P,A	;SAVE NAME
01100		PUSH P,B	;SAVE FUNCTIONS
01200		PUSH P,C
01300		PUSHJ P,ISSTR	;IS A REDUCTION ALREADY MADE?
01400		JUMPN A,LRRXIT	;YES
01500		CALLF @-1(P)	;NO, EXECUTE NON LEFT-RECURSIVE FUNCTION
01600		MOVEM A,-1(P)	;SAVE SEMANTIC VALUE
01700	LRRL:	CAIN A,NILX	;IS IT *NIL*?
01800		JRST LRRRET	;YES
01900		MOVEM A,-1(P)	;NO, SAVE SEMANTIC VALUE
02000		PUSHJ P,UNMARK	;RESET STACK TO MARK
02100		PUSHJ P,MARK
02200		HRRZ A,-1(P)	;GET SEMANTIC VALUE
02300		CALLF 1,@(P)	;EXECUTE LEFT-RECURSIVE FUNCTION
02400		JRST LRRL	;CONTINUE UNTIL FAILURE
02500
02600	LRRRET:	MOVE B,-1(P)	;GET FINAL SEMANTIC VALUE
02700		MOVE A,-2(P)	;GET NAME OF RULE(SYNTACTIC VALUE)
02800		PUSHJ P,REDUCE	;PERFORM THE REDUCTION
02900
03000	LRRXIT:	SUB P,[XWD 3,3]	;RESYNC THE STACK
03100		POPJ P,
03200
03300	;NLRR---NON LEFT-RECURSIVE RULE
03400	;A CONTAINS NAME OF RULE
03500	;B CONTAINS FUNCTION
03600
03700	NLRR:	PUSH P,A	;SAVE NAME
03800		PUSH P,B	;SAVE FUNCTION
03900		PUSHJ P,ISSTR	;IS THE REDUCTION ALREADY MADE?
04000		JUMPN A,NLRXIT	;YES
04100		POP P,A	;NO, GET FUNCTION
04200		CALLF (A)	;CALL FUNCTION
04300		POP P,B	;GET SYNTACTIC VALUE
04400		EXCH A,B
04500		JRST REDUCE	;PERFORM THE REDUCTION
04600
04700	NLRXIT:	SUB P,[XWD 2,2]	;RESYNC STACK
04800		POPJ P,
04900
05000
     

00100	
00200	INTERNAL PPOS,LOC,FLATC
00300	EXTERNAL TYO,CHRCT,TERPRI,CHCT,LINL
00400
00500	PPOS:	SUBI A,INUM0
00600		JUMPE A,TERPRI
00700		MOVEI C,(A)
00800		MOVE A,LINL
00900		SUB A,CHCT
01000		CAMGE C,A
01100		PUSHJ P,TERPRI
01200		JRST PPOS2
01300
01400	PPOS22:	MOVEI A,11
01500		PUSHJ P,TYO
01600	PPOS2:	MOVE B,LINL
01700		SUB B,CHCT
01800		CAIL C,8(B)
01900		JRST PPOS22
02000		SUB C,B
02100		MOVEI A,40
02200		JRST .+2
02300		PUSHJ P,TYO
02400		SOJGE C,.-1
02500		POPJ P,
02600
02700	LOC:	MOVE A,LINL
02800		SUB A,CHCT
02900		ADDI A,INUM0
03000		POPJ P,
03100
03200	FLATC:	HRROI R,FLATSIZE+5
03300		HLLZS FLATSIZE+3
03400		JRST FLATSIZE+2
03500
     

00100	
00200	INTERNAL OUTRULE,MATCH
00300
00400	PDLPTR←←REDPTR
00500	OUTRULE:	MOVE T,PDLPTR
00600		MOVNI A,-INUM0(A)	;SHOULD BE NEGATIVE NUMVAL
00700		ADDI A,(T)
00800		PUSH P,A
00900		PUSH T,(A)
01000		PUSH T,PDLMARK#
01100		MOVEM T,PDLMARK
01200		MOVEM T,PDLPTR
01300		CALLF (B)
01400		MOVE T,PDLMARK
01500		POP T,PDLMARK
01600		POP T,B
01700		POP P,B	;SHOULD BE PTR TO X.
01800		MOVEM T,PDLPTR
01900		JUMPN A,OR1
02000		MOVE T,PDLMARK
02100		MOVEM T,PDLPTR
02200		POPJ P,
02300
02400	OR1:	HRLZM A,(B)
02500		POPJ P,
     

00100	
00200	MATCH:	MOVE T,PDLMARK
00300		MOVE B,A
00400		HLRZ A,-1(T)
00500		MOVEM P,PSAV#
00600		PUSHJ P,MAT
00700		MOVEM T,PDLPTR
00800		JRST TRET
00900
01000	MAT:	CAIN B,STAR
01100		JRST MAT1
01200		PUSH P,A
01300		PUSH P,B
01400		CALL 1,ATOM
01500		JUMPN A,MAT2
01600		MOVE A,(P)
01700		CALL 1,ATOM
01800		JUMPN A,MAT2
01900		HLRZ A,@-1(P)
02000		HLRZ B,@(P)
02100		PUSHJ P,MAT
02200		HRRZ A,@-1(P)
02300		HRRZ B,@(P)
02400		SUB P,[XWD 2,2]
02500		JRST MAT
02600
02700	MAT1:	HRLZS A
02800		PUSH T,A
02900		POPJ P,
03000
03100	MAT2:	POP P,B
03200		POP P,A
03300		CAMN A,B
03400		POPJ P,
03500
03600	MAT3:	MOVE P,PSAV
03700		JRST NILRET
03800
     

00100	
00200		END